home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmpwt.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
5KB
|
134 lines
;;; CMPWT Output routines.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(defun wt-comment (message &optional (symbol nil))
(princ "
/* " *compiler-output1*)
(princ message *compiler-output1*)
(when symbol
(let ((s (symbol-name symbol)))
(declare (string s))
(dotimes** (n (length s))
(let ((c (schar s n)))
(declare (character c))
(unless (char= c #\/)
(princ c *compiler-output1*))))))
(princ " */
" *compiler-output1*)
nil
)
(defun wt1 (form)
(cond ((or (stringp form) (integerp form) (characterp form))
(princ form *compiler-output1*))
((or (typep form 'long-float)
(typep form 'short-float))
(format *compiler-output1* "~10,,,,,,'eG" form))
(t (wt-loc form)))
nil)
(defun wt-h1 (form)
(cond ((consp form)
(let ((fun (get (car form) 'wt)))
(if fun
(apply fun (cdr form))
(cmpiler-error "The location ~s is undefined." form))))
(t (princ form *compiler-output2*)))
nil)
(defun wt-data (expr)
(let ((*print-radix* nil)
(*print-base* 10)
(*print-circle* t)
(*print-pretty* nil)
(*print-level* nil)
(*print-length* nil)
(*print-case* :downcase)
(*print-gensym* t)
(*print-array* t)
(si::*print-package* t)
(si::*print-structure* t))
(terpri *compiler-output-data*)
(prin1 expr *compiler-output-data*)
nil))
(defun wt-data-begin ()
(princ " " *compiler-output-data*)
(terpri *compiler-output-data*)
(princ "#(" *compiler-output-data*)
nil)
(defun wt-data-end ()
(terpri *compiler-output-data*)
(princ ")" *compiler-output-data*)
(terpri *compiler-output-data*)
nil)
(defun wt-data-package-operation (form)
(terpri *compiler-output-data*)
(princ "#!" *compiler-output-data*)
(wt-data form))
(defmacro wt (&rest forms &aux (fl nil))
(dolist** (form forms (cons 'progn (reverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output1*) fl)
(push `(wt1 ,form) fl))))
(defmacro wt-h (&rest forms &aux (fl nil))
(cond ((endp forms) '(princ "
" *compiler-output2*))
((stringp (car forms))
(dolist** (form (cdr forms)
(list* 'progn `(princ ,(concatenate 'string "
" (car forms)) *compiler-output2*) (reverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output2*) fl)
(push `(wt-h1 ,form) fl))))
(t (dolist** (form forms
(list* 'progn '(princ "
" *compiler-output2*) (reverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output2*) fl)
(push `(wt-h1 ,form) fl))))))
(defmacro wt-nl (&rest forms &aux (fl nil))
(cond ((endp forms) '(princ "
" *compiler-output1*))
((stringp (car forms))
(dolist** (form (cdr forms)
(list* 'progn `(princ ,(concatenate 'string "
" (car forms)) *compiler-output1*) (reverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output1*) fl)
(push `(wt1 ,form) fl))))
(t (dolist** (form forms
(list* 'progn '(princ "
" *compiler-output1*) (reverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output1*) fl)
(push `(wt1 ,form) fl))))))
(defmacro wt-nl1 (&rest forms &aux (fl nil))
(cond ((endp forms) '(princ "
" *compiler-output1*))
((stringp (car forms))
(dolist** (form (cdr forms)
(list* 'progn `(princ ,(concatenate 'string "
" (car forms)) *compiler-output1*) (reverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output1*) fl)
(push `(wt1 ,form) fl))))
(t (dolist** (form forms
(list* 'progn '(princ "
" *compiler-output1*) (reverse (cons nil fl))))
(if (stringp form)
(push `(princ ,form *compiler-output1*) fl)
(push `(wt1 ,form) fl))))))